home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clcs / handler.lisp < prev    next >
Text File  |  1990-12-06  |  5KB  |  139 lines
  1. ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-
  2.  
  3. (IN-PACKAGE "CONDITIONS")
  4.  
  5. (DEFVAR *HANDLER-CLUSTERS* NIL)
  6.  
  7. (DEFMACRO HANDLER-BIND (BINDINGS &BODY FORMS)
  8.   (UNLESS (EVERY #'(LAMBDA (X) (AND (LISTP X) (= (LENGTH X) 2))) BINDINGS)
  9.     (ERROR "Ill-formed handler bindings."))
  10.   `(LET ((*HANDLER-CLUSTERS* (CONS (LIST ,@(MAPCAR #'(LAMBDA (X) `(CONS ',(CAR X) ,(CADR X)))
  11.                            BINDINGS))
  12.                    *HANDLER-CLUSTERS*)))
  13.      ,@FORMS))
  14.  
  15. (DEFVAR *BREAK-ON-SIGNALS* NIL)
  16.  
  17. (DEFUN SIGNAL (DATUM &REST ARGUMENTS)
  18.   (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-CONDITION 'SIGNAL))
  19.         (*HANDLER-CLUSTERS* *HANDLER-CLUSTERS*))
  20.     (IF (TYPEP CONDITION *BREAK-ON-SIGNALS*)
  21.     (BREAK "~A~%Break entered because of *BREAK-ON-SIGNALS*."
  22.            CONDITION))
  23.     (LOOP (IF (NOT *HANDLER-CLUSTERS*) (RETURN))
  24.           (LET ((CLUSTER (POP *HANDLER-CLUSTERS*)))
  25.         (DOLIST (HANDLER CLUSTER)
  26.           (WHEN (TYPEP CONDITION (CAR HANDLER))
  27.         (FUNCALL (CDR HANDLER) CONDITION)
  28.         (RETURN NIL) ;?
  29.         ))))
  30.     NIL))
  31.  
  32. ;;; COERCE-TO-CONDITION
  33. ;;;  Internal routine used in ERROR, CERROR, BREAK, and WARN for parsing the
  34. ;;;  hairy argument conventions into a single argument that's directly usable 
  35. ;;;  by all the other routines.
  36.  
  37. (DEFUN COERCE-TO-CONDITION (DATUM ARGUMENTS DEFAULT-TYPE FUNCTION-NAME)
  38.   #+LISPM (SETQ ARGUMENTS (COPY-LIST ARGUMENTS))
  39.   (COND ((CONDITIONP DATUM)
  40.      (IF ARGUMENTS
  41.          (CERROR "Ignore the additional arguments."
  42.              'SIMPLE-TYPE-ERROR
  43.              :DATUM ARGUMENTS
  44.              :EXPECTED-TYPE 'NULL
  45.              :FORMAT-STRING "You may not supply additional arguments ~
  46.                      when giving ~S to ~S."
  47.              :FORMAT-ARGUMENTS (LIST DATUM FUNCTION-NAME)))
  48.      DATUM)
  49.         ((OR (SYMBOLP DATUM) (CONDITION-CLASS-P DATUM))
  50.          (APPLY #'MAKE-CONDITION DATUM ARGUMENTS))     
  51.         ((STRINGP DATUM)
  52.      (MAKE-CONDITION DEFAULT-TYPE
  53.                          :FORMAT-STRING DATUM
  54.                          :FORMAT-ARGUMENTS ARGUMENTS))
  55.         (T
  56.          (ERROR 'SIMPLE-TYPE-ERROR
  57.         :DATUM DATUM
  58.         :EXPECTED-TYPE '(OR SYMBOL STRING)
  59.         :FORMAT-STRING "Bad argument to ~S: ~S"
  60.         :FORMAT-ARGUMENTS (LIST FUNCTION-NAME DATUM)))))
  61.  
  62. (DEFUN ERROR (DATUM &REST ARGUMENTS)
  63.   (LET ((CONDITION (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-ERROR 'ERROR)))
  64.     (SIGNAL CONDITION)
  65.     (INVOKE-DEBUGGER CONDITION)))
  66.  
  67. (DEFUN CERROR (CONTINUE-STRING DATUM &REST ARGUMENTS)
  68.   (WITH-SIMPLE-RESTART (CONTINUE "~A" (APPLY #'FORMAT NIL CONTINUE-STRING ARGUMENTS))
  69.     (APPLY #'ERROR DATUM ARGUMENTS))
  70.   NIL)
  71.  
  72. (DEFUN BREAK (&OPTIONAL (FORMAT-STRING "Break") &REST FORMAT-ARGUMENTS)
  73.   (WITH-SIMPLE-RESTART (CONTINUE "Return from BREAK.")
  74.     (INVOKE-DEBUGGER
  75.       (MAKE-CONDITION 'SIMPLE-CONDITION
  76.               :FORMAT-STRING    FORMAT-STRING
  77.               :FORMAT-ARGUMENTS FORMAT-ARGUMENTS)))
  78.   NIL)
  79.  
  80. (DEFUN WARN (DATUM &REST ARGUMENTS)
  81.   (LET ((CONDITION
  82.       (COERCE-TO-CONDITION DATUM ARGUMENTS 'SIMPLE-WARNING 'WARN)))
  83.     (CHECK-TYPE CONDITION WARNING "a warning condition")
  84.     (IF *BREAK-ON-WARNINGS*
  85.     (BREAK "~A~%Break entered because of *BREAK-ON-WARNINGS*."
  86.            CONDITION))
  87.     (RESTART-CASE (SIGNAL CONDITION)
  88.       (MUFFLE-WARNING ()
  89.       :REPORT "Skip warning."
  90.     (RETURN-FROM WARN NIL)))
  91.     (FORMAT *ERROR-OUTPUT* "~&Warning:~%~A~%" CONDITION)
  92.     NIL))
  93.  
  94. (DEFMACRO HANDLER-CASE (FORM &REST CASES)
  95.   (LET ((NO-ERROR-CLAUSE (ASSOC ':NO-ERROR CASES)))
  96.     (IF NO-ERROR-CLAUSE
  97.     (LET ((NORMAL-RETURN (MAKE-SYMBOL "NORMAL-RETURN"))
  98.           (ERROR-RETURN  (MAKE-SYMBOL "ERROR-RETURN")))
  99.       `(BLOCK ,ERROR-RETURN
  100.          (MULTIPLE-VALUE-CALL #'(LAMBDA ,@(CDR NO-ERROR-CLAUSE))
  101.            (BLOCK ,NORMAL-RETURN
  102.          (RETURN-FROM ,ERROR-RETURN
  103.            (HANDLER-CASE (RETURN-FROM ,NORMAL-RETURN ,FORM)
  104.              ,@(REMOVE NO-ERROR-CLAUSE CASES)))))))
  105.     (LET ((TAG (GENSYM))
  106.           (VAR (GENSYM))
  107.           (ANNOTATED-CASES (MAPCAR #'(LAMBDA (CASE) (CONS (GENSYM) CASE))
  108.                        CASES)))
  109.       `(BLOCK ,TAG
  110.          (LET ((,VAR NIL))
  111.            ,VAR                ;ignorable
  112.            (TAGBODY
  113.          (HANDLER-BIND ,(MAPCAR #'(LAMBDA (ANNOTATED-CASE)
  114.                         (LIST (CADR ANNOTATED-CASE)
  115.                           `#'(LAMBDA (TEMP)
  116.                                ,@(IF (CADDR ANNOTATED-CASE)
  117.                                  `((SETQ ,VAR TEMP)))
  118.                                (GO ,(CAR ANNOTATED-CASE)))))
  119.                     ANNOTATED-CASES)
  120.                    (RETURN-FROM ,TAG ,FORM))
  121.          ,@(MAPCAN #'(LAMBDA (ANNOTATED-CASE)
  122.                    (LIST (CAR ANNOTATED-CASE)
  123.                      (LET ((BODY (CDDDR ANNOTATED-CASE)))
  124.                        `(RETURN-FROM ,TAG
  125.                       ,(COND ((CADDR ANNOTATED-CASE)
  126.                           `(LET ((,(CAADDR ANNOTATED-CASE)
  127.                               ,VAR))
  128.                              ,@BODY))
  129.                          ((NOT (CDR BODY))
  130.                           (CAR BODY))
  131.                          (T
  132.                           `(PROGN ,@BODY)))))))
  133.                ANNOTATED-CASES))))))))
  134.  
  135. (DEFMACRO IGNORE-ERRORS (&REST FORMS)
  136.   `(HANDLER-CASE (PROGN ,@FORMS)
  137.      (ERROR (CONDITION) (VALUES NIL CONDITION))))
  138.  
  139.